;; This holds a compiler and VM that excecutes the compiled code.

;; The compiler transforms the input scheme expression into an
;; "assembly code" for the VM. This is not in linear form
;; (unlike what one would expect) rather, it is in the form of
;; a directed, acrylic graph that may be processed without the
;; need for label and jumps.

;; Assembly Code
;; -------------
;; The assembly code of the VM describes in this section consists
;; of 12 instructions each with zero or more operands. The
;; instructions are described below.
;; 1. (halt) halts the VM. Returns the value in accumulator as the
;; result.
;; 2. (refer var x) finds the value of var in the current environment,
;; and places this value in the accumulator and sets the next
;; expression to x.
;; 3. (constant obj x) places obj into the accumulator and sets the
;; next expression to x.
;; 4. (close vars body x) creates a closure from body, vars and the
;; current environemt, places the closure into the accumulator, sets
;; the next expression to x.
;; 5. (test then else) tests the accumulator and if the accumulator is
;; notnull, sets the next expression to then. Otherwise test sets the
;; next expression to else.
;; 6. (assign var x) changes the current environment binding for the
;; variable var to the value in the accumulator and sets the next
;; expression to x.
;; 7. (conti x) creates a continuation from the stack and places this
;; continuation in the accumulator, sets the next expression to x.
;; 8. (nuate s var) restores s to be the current stack, sets the
;; accumulator to the value of var in the current environmanet, and
;; sets the next expression to (return)
;; 9. (frame x ret) creates a new frame from the current environment,
;; the current rib, and ret as the next expression, adds this frame to
;; the current stack, sets the current rib to the empty list and sets
;; the next expression to x.
;; 10. (argument x) adds the value in the accumulator to the current
;; rib and sets the next expression to x.
;; 11. (apply) applies the closure in the accumulator to the list of
;; values in the current rib.
;; 12. (return) removes the first frame from the stack and resets the
;; current environment, the current rub, the next respression and the
;; current stack.

;; The compiler transforms Scheme expressions into the assembly
;; language instructions listed above. Some Scheme expressions, such
;; as variables and constants, are transformed into a single assembly
;; language instruction. Others, such as applications, are turned into
;; several instructions.The compiler looks for each type of expression
;; in turn and converts it into the corresponding instructions. The
;; inputs to the compiler are the expression to compile and the next
;; instruction to perform after the expression completes. The next
;; instruction may be thought of as the continuation of the expression
;; (not to be confused with continuation ob jects returned by
;; call/cc).

(define compile
  (lambda (x next)
    (cond
     [(symbol? x)
      (list 'refer x next)]
     [(pair? x)
      (record-case x
                   [quote (obj)
                          (list 'constant obj next)]
                   [lambda (vars body)
                     (list 'close vars (compile body '(return)) next)]
                   [if (test then else)
                       (let ([thenc (compile then next)]
                             [elsec (compile else next)])
                         (compile test (list 'test thenc elsec)))]
                   [set! (var x)
                         (compile x (list 'assign var next))]
                   [call/cc (x)
                            (let ([c (list 'conti
                                           (list 'argument
                                                 (compile x '(apply))))])
                              (if (tail? next)
                                  c
                                  (list 'frame next c)))]
                   [else
                    (recur loop ([args (cdr x)]
                                 [c (compile (car x) '(apply))])
                           (if (null? args)
                               (if (tail? next)
                                   c
                                   (list 'frame next c))
                               (loop (cdr args)
                                     (compile (car args)
                                              (list 'argument c)))))])]
     [else
      (list 'constant x next)])))

(define tail?
  (lambda (next)
    (eq? (car next) 'return)))

;; The VM interprets the instructions produced by the compiler given
;; above, using the data structures and registers described earlier.
;; Its structure is similar to that of a SECD machine the state
;; changes to a set of registers are modeled by a tail recursion
;; function. The arguments to the function are the registers
;; themselves. Each recursive call to the VM signals the start of a
;; new machine cycle, the new values for the VM regesters are
;; specified by the arguments.

(define VM
  (lambda (a x e r s)
    (record-case x
                 [halt () a]
                 [refer (var x)
                        (VM (car (lookup var e)) x e r s)]
                 [constant (obj x)
                           (VM obj x e r s)]
                 [close (vars body x)
                        (VM (closure body e vars) x e r s)]
                 [test (then else)
                       (VM a (if a then else) e r s)]
                 [assign (var x)
                         (set-car! (lookup var e) a)
                         (VM a x e r s)]
                 [conti (x)
                        (VM (continuation s) x e r s)]
                 [nuate (s var)
                        (VM (car (lookup var e)) '(return) e r s)]
                 [frame (ret x)
                        (VM a x e '() (call-frame ret e r s))]
                 [argument (x)
                           (VM a x e (cons a r) s)]
                 [apply ()
                        (record a (body e vars)
                                (VM a body (extend e vars r) '() s))]
                 [return ()
                         (record s (x e r s)
                                 (VM a x e r s))])))

(define lookup
  (lambda (var e)
    (recur nxtrib ([e e])
           (recur nxtelt ([vars (caar e)] [vals (cdar e)])
                  (cond
                   [(null? vars) (nxtrib (cdr e))]
                   [(eq? (car vars) var) vals]
                   [else (nxtelt (cdr vars) (cdr vals))])))))

(define closure
  (lambda (body e vars)
    (list body e vars)))

(define continuation
  (lambda (s)
    (closure (list 'nuate s 'v) '() '(v))))

(define call-frame
  (lamda (x e r s)
         (list x e r s)))

(define extend
  (lambda (e vars vals)
    (cons (cons vars vals) e)))

(define evaluate
  (lambda (x)
    (VM '() (compile x '(halt)) '() '() '())))





